;;;;;
;;;;; COMPILER
;;;;;

(define-record-type project :project
  (really-make-project name directory includes)
  (name project-name)
  (directory project-directory)
  (includes project-includes))

(define (make-project name directory . includes)
  (really-make-project name directory includes))

(define (project-filename project component-name)
  (define dir (project-directory project))
  (and dir
       (string-append dir
		      "/"
		      (cs-style component-name #t)
		      ".cs")))

(define-syntax define-module
  (syntax-rules ()
    ((define-module (project component) form ...)
     (compile-program (project-filename project 'component)
		      (project-name project)
		      (project-includes project)
		      '(form ...)))))

(define copyright-notice "Copyright (C) Ian Horswill 2004, 2005, 2006; See the file COPYING for licensing information.")

(define (compile-program filename namespace includes program-text)
  (define program (map simplify
		       (map parse program-text)))
  (define (compile-program)
    (emit-text-line "//")
    (emit-text "// ")
    (emit-text-line copyright-notice)
    (emit-text-line "//")
    (emit-text-line "// This file is automatically generated.  Do not edit it.")
    (emit-text-line "//")
    (emit-text-line "using System;")
    (for-each (lambda (include)
		(emit-formatted-text-line "using ~A;" include))
	      includes)
    (emit-newline)
    (emit-formatted-text-line "namespace ~A {" namespace)
    (with-indent 3
		 (lambda ()
		   (for-each compile program)))
    (emit-text-line "}"))

  (with-front-end-error-handler
   (lambda ()
     (for-each analyze program)
     (if filename
	 (call-with-output-file filename
	   (lambda (port)
	     (with-compilation-output port compile-program)))
	 (with-compilation-output (current-output-port) compile-program)))))

;;;;
;;;; TOP-LEVEL FORMS
;;;;

(define-method (compile (c class-definition))
  (define inits (initargs c))
  (define abstract? (not (initargs c)))
  (define parent-type (type-expression-value (parent c)))
  (define (compile-members)
    (unless abstract?
      (compile-constructor))
    (for-each (lambda (mem)
		(unless (eq? (name (var mem)) 'initialize!)
		  (compile mem)))
	      (members c)))

  (define (compile-constructor)
    (define initializer
      (let loop ((mems (members c)))
	(cond ((null? mems)
	       #f)
	      ((eq? (name (var (car mems))) 'initialize!)
	       (car mems))
	      (else
	       (loop (cdr mems))))))
    (emit-formatted-text "public ~A("
			 (native-name (current-value (name c))))
    (do-args (lambda (var)
	       (emit-type (result (type var)))
	       (emit-formatted-text " ~AArg"
				    (native-variable-name var)))
	     emit-comma
	     inits)
    (emit-formatted-text-line ") ~A {"
		    (if (and initializer
			     (memq 'base (keywords initializer)))
			": base() "
			""))
    (with-indent 3 
		 (lambda ()
		   (init-members)
		   (when initializer
		     (compile-body (body (value initializer))
				   null-continuer))))
    (emit-text-line "}"))

  (define (init-members)
    (for-each (lambda (init)
		(define n (native-variable-name init))
		(emit-formatted-text-line "~A=~AArg;" n n))
	      inits)
    (for-each (lambda (member)
		(define val (value member))
		(define v (var member))
		(when (and (not (is? val lambda-expression))
			   (not (memq 'static (keywords member)))
			   (not (memq v inits)))
		  (emit-formatted-text "~A=" (native-variable-name v))
					;(emit-token (value val))
		  (compile val)
		  (emit-text-line ";")))
	      (members c)))

  (now-compiling-class
   c
   (lambda ()
     (set (type base) parent-type)
;     (unless (not (value (car (members c))))
     (for-each emit-attribute
	       (attributes c))
     (emit-formatted-text "public ~Aclass ~A : ~A"
			  (if abstract?
			      "abstract "
			      "")
			  (native-name (current-value (name c)))
			  (native-name parent-type))
     (unless (null? (interfaces c))
       (emit-text ", ")
       (do-args emit-text emit-comma (interfaces c)))
     (emit-text-line " {")
     (with-indent 3 compile-members)
     (emit-text-line "}"))))

(define-method (compile (m member-definition))
  (define v (var m))
  (define k (keywords m))
  (define val (value m))
  (define (override keyword)
    (if (memq keyword '(abstract virtual))
	'override
	keyword))

  (now-compiling m
		 (lambda ()
		   (for-each (lambda (k)
			       (if (string? k)
				   (emit-attribute k)))
			     (keywords v))
		   (if (is? val lambda-expression)
		       (compile-method (native-variable-name v)
				       v
				       (or k
					   (map override
						(keywords v)))
				       val)
		       (compile-field (name v)
				      (or (native-name m)
					  (native-field-name (name v)))
				      (rtype m)
				      k
				      val)))))

(define (compile-method method-name method-var keywords lambda-expression)
  (define static? (static-keys? keywords))
  (define property? (memq 'property keywords))

  (for-each (lambda (key)
	      (unless (or (string? key)
			  (eq? key 'property))
		(emit-text key)
		(emit-text " ")))
	    keywords)
  (emit-type (result (type method-var)))
  (emit-text " ")
  (emit-name method-name)
  (unless property?
    (emit-text "(")
    (do-args emit-decl emit-comma
	     (if static?
		 (variables lambda-expression)
		 ;; Don't write out this-arg
		 (cdr (variables lambda-expression)))))
  (cond ((not (memq 'abstract keywords))
	 (if property?
	   (emit-text-line " {")
	   (emit-text ") {"))
	 (with-indent 3
		      (lambda ()
			(define b (body lambda-expression))
			(emit-newline)
			(when property?
			  (emit-text-line "get {"))
			(compile-body b
				      (if (eq? (type (last b))
					       void-type)
					  void-return-continuer
					  return-continuer))
			(when property?
			  (emit-text-line "}"))))
	 (emit-text-line "}"))
	(else
	 (emit-text-line ");"))))

(define (compile-field name field-name rtype keywords value)
  (define static? (static-keys? keywords))
  (when keywords
    (for-each (lambda (key)
		(unless (string? key)
		  (emit-text key)
		  (emit-text " ")))
	      keywords)
    (cond (static?
	   (emit-formatted-text "~A ~A = "
				(native-name (type-expression-value rtype))
				field-name)
	   (compile value)
	   (emit-text-line ";"))
	  (else
	   (emit-formatted-text-line "~A ~A;"
				     (native-name
				      (type-expression-value rtype))
				     field-name)))))


;;;;
;;;; "REAL" EXPRESSIONS
;;;;

(define-method (compile (c constant))
  (emit-token (value c)))

(define-method (compile (g global-variable))
  (emit-name (or (native-name g)
		 (native-variable-name g))))

(define-method (compile (l local-variable))
  (emit-name (native-variable-name l)))

(define-method (compile (c conditional))
  (compile-call the-conditional-operator
		(subexpressions c)
		(type c)
		0))

(define-method (compile (x set-expression))
  (compile (lvalue x))
  (emit-text " = ")
  (compile (rvalue x)))

(define-method (compile (a application))
  (compile-application (operator a)
		       (arguments a)
		       a
		       (type a)
		       -1))

(define-method (compile (t the-expression))
  (compile (exp t)))

(define-method (compile (t cast-expression))
  (maybe-cast (type t)
	      (type (exp t))
	      (lambda (prec)
		(compile (exp t)))
	      0))


;;;;
;;;; COMPILING SPECIFIC KINDS OF PROCEDURE CALLS
;;;;

(define-method (compile-application (op expression) args exp type prec)
  (error "Invalid operator in procedure position"
	 (cons (unparse op)
	       (map unparse args))))

(define-method (compile-application (op global-variable) args exp type prec)
  (define proc (current-value op))

  (cond ((is? proc user-type)
	 (compile-construction proc args type prec))
	((eq? proc void-type)
	 ;; Do nothing!
	 )
	((eq? op the-array-var)
	 (emit-text (native-name (type-expression-value exp))))
	(else
	 (compile-call proc args type prec))))

(define-method (compile-call (m method) args t prec)
  (define object-arg (first args))
  (define real-args (cdr args))

  (define (doit prec)
    (unless (and (is? object-arg local-variable)
		 (eq? (name object-arg) 'this))
      (compile object-arg)
      (emit-text "."))
    (cond ((memq 'property (method-keywords m))
	   (emit-name (name m)))
	  (else
	   (emit-formatted-text "~A(" (name m))
	   (do-args compile emit-comma real-args)
	   (emit-text ")"))))

  (maybe-cast t (method-type m) doit prec))

(define-method (compile-call (f field) args t prec)
  (define object-arg (first args))

  (unless (and (is? object-arg local-variable)
	       (eq? (name object-arg) 'this))
    (compile object-arg)
    (emit-text "."))
  (emit-name (name f)))

(define-method (compile-call (n new-operator) args t prec)
  (compile-construction (type-expression-value (car args))
			(cdr args)
			t
			prec))

(define (compile-construction type args t prec)
  (emit-formatted-text "new ~A("
		       (native-name type))
  (do-args compile emit-comma args)
  (emit-text ")"))

(define-method (compile-call (n new-array-operator) args t prec)
  (define type-arg (type-expression-value (car args)))
  (define length-arg (cadr args))
  (define initializers (cddr args))

  (cond ((is? type-arg array-type-class)
	 ;; KLUGE!  Jagged arrays!
	 (emit-formatted-text "new ~A["
			      (native-name (base-type type-arg)))
	 (compile length-arg)
	 (emit-text "][]")
	 (unless (null? initializers)
	   (emit-text " {")
	   (do-args compile emit-comma initializers)
	   (emit-text "}"))
	 )
	(else
	 (emit-formatted-text "new ~A["
			      (native-name type-arg))
	 (compile length-arg)
	 (emit-text "]")
	 (unless (null? initializers)
	   (emit-text " {")
	   (do-args compile emit-comma initializers)
	   (emit-text "}")))))

(define-method (compile-call (p native-procedure) args t prec)
  (emit-name (native-name p))
  (emit-text "(")
  (do-args compile emit-comma args)
  (emit-text ")"))

(define-method (compile-call (p native-operator) args t prec)
  (define my-prec (precedence p))
  (define op-type (operator-type p))
  (define (doit prec)
    (cond ((eq? p the-conditional-operator)
	   (maybe-parenthesize my-prec prec
			       (lambda (new-prec)
				 (compile-infix (car args)
						boolean-type
						my-prec)
				 (emit-text "?")
				 (compile-infix (cadr args) t my-prec)
				 (emit-text ":")
				 (compile-infix (caddr args) t my-prec))))
	  (else
	   (maybe-parenthesize my-prec prec
			       (lambda (new-prec)
				 (when (= (length args) 1)
				   (emit-text (native-name p)))
				 (do-args (lambda (arg)
					    (compile-infix arg
							   (type arg)
							   my-prec))
					  (lambda ()
					    (emit-name (native-name p)))
					  args)
				 (when (eq? (native-name p)
					    index-operator)
				   (emit-text "]")))))))

  (maybe-cast t
	      (if (is? op-type procedure-type)
		  (result-type (operator-type p)
			       (map type args))
		  t)
	      doit
	      prec))

(define-method (compile-infix (e expression) t prec)
  (compile e))

(define-method (compile-infix (a application) t prec)
  (compile-application (operator a) (arguments a) a t prec))

(define (maybe-parenthesize operator-prec outer-prec thunk)
  (cond ((> operator-prec outer-prec)
	 (thunk outer-prec))
	(else
	 (emit-text "(")
	 (thunk 0)
	 (emit-text ")"))))

(define cast-prec 2)
(define (maybe-cast target-type actual-type thunk prec)
  (define numeric-type?
    (or (eq? actual-type float-type)
	(eq? actual-type single-float-type)
	(eq? actual-type integer-type)))
  (define (cast prec)
    (cond ((eq? target-type float-type)
	   (cond (numeric-type?
		  (emit-text "((double)")
		  (thunk cast-prec)
		  (emit-text ")"))
		 (else
		  (emit-text "System.Convert.ToDouble(")
		  (thunk cast-prec)
		  (emit-text ")"))))
	  ((eq? target-type single-float-type)
	   (cond (numeric-type?
		  (emit-text "((float)")
		  (thunk cast-prec)
		  (emit-text ")"))
		 (else
		  (emit-text "System.Convert.ToSingle(")
		  (thunk cast-prec)
		  (emit-text ")"))))
	  (else
	   (emit-formatted-text "((~A)(" (native-name target-type))
	   (thunk cast-prec)
	   (emit-text "))"))))
  (cond ((or (eq? target-type void-type)
	     (type-<=? actual-type target-type))
	 (thunk prec))
	(else
	 (maybe-parenthesize cast-prec prec cast))))		     
			     

;;;;
;;;; COMPILING STATEMENTS
;;;;

(define (compile-body body continuer)
  (let loop ((forms body))
    (let ((form (car forms))
	  (rest (cdr forms)))
      (cond ((null? rest)
	     (compile-statement form continuer))
	    (else
	     (compile-statement form null-continuer)
	     (loop rest))))))

(define-method (compile-statement (e expression) continuer)
  (continuer e))

(define-method (compile-statement (b begin-expression) continuer)
  (compile-body (body b) continuer))

(define-method (compile-statement (r return) continuer)
  (compile-statement (exp r) return-continuer))

(define-method (compile-statement (l let-expression) continuer)
  (for-each compile-initialization (variables l))
  (compile-body (body l) continuer))

(define-method (compile-statement (f for-expression) continuer)
  (emit-text "for (")
  (do-args (lambda (var)
	     (emit-formatted-text "~A ~A = "
				  (native-name (type var))
				  (native-variable-name var))
	     (compile (initial-value var)))
	   emit-comma
	   (variables f))
  (emit-text "; ")
  (compile (test f))
  (emit-text "; ")
  (do-args (lambda (var/iter)
	     (let ((var (car var/iter))
		   (iter (cdr var/iter)))
	       (emit-formatted-text "~A=" (native-variable-name var))
	       (compile iter)))
	   emit-comma
	   (map cons
		(variables f)
		(iterators f)))
  (emit-text-line ") {")
  (with-indent 3
	       (lambda ()
		 (compile-body (body f) null-continuer)))
  (emit-text-line "}"))

(define (compile-initialization v)
  (define i (initial-value v))
  (define n (native-variable-name v))

  (cond ((contains-statements? i)
	 (if (memq (type v)
		   value-types)
	     (emit-formatted-text-line "~A ~A=new ~A();"
				       (native-name (type v))
				       n
				       (native-name (type v)))
	     (emit-formatted-text-line "~A ~A=null;"
				       (native-name (type v))
				       n))
	 (compile-statement i (make-assignment-continuer v)))
	(else
	 (emit-formatted-text "~A ~A = "
			      (native-name (type v))
			      n)
	 (compile (initial-value v))
	 (emit-text-line ";"))))

(define-method (compile-statement (c conditional) continuer)
  (define tes (test c))
  (define con (consequent c))
  (define alt (alternative c))

  (let ((complex-con? (or (contains-statements? con)
			  (is? con conditional))))
    (emit-text "if (")
    (compile tes)
    (emit-formatted-text-line ")~A"
			      (if complex-con?
				  " {"
				  ""))
    (with-indent 3
		 (lambda ()
		   (compile-statement con continuer)))
    (if (null? alt)
	(when complex-con?
	  (emit-text-line "}"))
	(let ((complex-alt? (contains-statements? alt)))
	   (emit-formatted-text-line "~Aelse~A"
				     (if complex-con? "} " "")
				     (if complex-alt? " {" ""))
	   (with-indent 3
			(lambda ()
			  (compile-statement alt continuer)))
	   (when complex-alt?
	     (emit-text-line "}"))))))

(define-method (compile-statement (w while-expression) continuer)
  (emit-text "while (")
  (compile (test w))
  (emit-text-line ") {")
  (with-indent 3 (lambda () (compile-body (body w) null-continuer)))
  (emit-text-line "}"))

;;;;
;;;; GENERAL UTILITIES
;;;;

(define (emit-comma)
  (emit-text ", "))

(define (do-args proc in-between args)
  (unless (null? args)
    (let loop ((l args))
      (proc (car l))
      (when (pair? (cdr l))
	(in-between)
	(loop (cdr l))))))

(define (emit-decl var)
  (emit-type (type var))
  (emit-text " ")
  (emit-name (native-variable-name var)))

(define (null-continuer e)
  (unless (is? e constant)
    (compile e)
    (emit-text-line ";")))

(define throw-var (parse 'throw))

(define (is-throw? e)
  (let ((answer (and (is? e application)
		     (eq? (operator e) throw-var))))
;		     (let ((o (operator e)))
;		       (and (is? o global-variable)
;			    (eq? (name o) 'throw))))))

;    (format #t "~S => ~S~%" (unparse e) answer)
    answer))

(define (return-continuer e)
  (unless (is-throw? e)
    (emit-text "return "))
  (compile e)
  (emit-text-line ";"))

;(define (void-return-continuer e)
;  (unless (is? e constant)
;    (null-continuer e))
;  (emit-text-line "return;"))

(define void-return-continuer null-continuer)

(define (make-assignment-continuer var)
  (define (assignment-continuer e)
    (unless (is-throw? e)
      (emit-name (native-variable-name var))
      (emit-text "="))
    (compile e)
    (emit-text-line ";"))
  assignment-continuer)

(define (emit-check v)
  (define t (type v))

  (cond ((eq? t float-type)
	 (emit-formatted-text "Convert.ToDouble(~A)"
			      (native-variable-name v)))
	(else
	 (emit-formatted-text "(~A)~A"
			      (native-name t)
			      (native-variable-name v)))))

;;;;
;;;; ERROR HANDLING STUFF
;;;;

(define $current-class (make-fluid #f))
(define $current-expression (make-fluid #f))
(define (with-front-end-error-handler thunk)
  (define (front-end-error-handler c punt)
    (define port (current-error-port))
    (when (and (or (error? c) (warning? c))
               (fluid $current-class))
      (force-output (current-output-port))
      (format port "~%~%~A occurred while compiling class ~S.~%"
              (if (error? c)
                  "An error"
                  "A warning")
	      (ignore-errors 
	       (lambda ()
		 (unparse (name (fluid $current-class))))))
      (when (fluid $current-expression)
	(ignore-errors (lambda () (pretty-print
				   (unparse (fluid $current-expression)))))
	(newline port)))
    (punt))
  (with-handler front-end-error-handler thunk))

(define (now-compiling expression thunk)
  (let-fluid $current-expression expression thunk))
(define (now-compiling-class c thunk)
  (let-fluid $current-class c thunk))

(define pretty-print (structure-ref big-scheme p))